home *** CD-ROM | disk | FTP | other *** search
- {-------------------------------------------------------------------------
- Module: TGlobe Demo program
-
- Comment: Simple demo program for TGlobe.
-
- Author: Graham Knight
- Email: gknight@helmstone.co.uk
- Version: 2.2
- Date: January 1998
-
- 2.1a: Fix to object selection in lbxLocationsclick()
- -------------------------------------------------------------------------}
- unit uDemo;
-
- interface
-
- uses
- WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms,
- Dialogs, StdCtrls, Buttons, ExtCtrls, Menus, Tabs, inifiles, Spin;
-
- type
- TfrmMain = class(TForm)
- MainMenu1: TMainMenu;
- File1: TMenuItem;
- Open1: TMenuItem;
- N1: TMenuItem;
- Exit1: TMenuItem;
- Panel3: TPanel;
- Globe: TGlobe;
- OpenDialog1: TOpenDialog;
- pnlHint: TPanel;
- View1: TMenuItem;
- Spherical1: TMenuItem;
- Mercator1: TMenuItem;
- Cartesian1: TMenuItem;
- Panel1: TPanel;
- Notebook1: TNotebook;
- lbxLocations: TListBox;
- Panel4: TPanel;
- btnType: TButton;
- btnTitle: TButton;
- pnlZoom: TPanel;
- btnZoomIn: TBitBtn;
- btnZoomOut: TBitBtn;
- btnZoomExtents: TBitBtn;
- SpinButton1: TSpinButton;
- tabLayers: TTabSet;
- OpenProfile1: TMenuItem;
- OpenDialog3: TOpenDialog;
- NewGlobe: TMenuItem;
- N2: TMenuItem;
- ThematicMapping1: TMenuItem;
- Timer1: TTimer;
- N3: TMenuItem;
- Print1: TMenuItem;
- procedure btnZoomInClick(Sender: TObject);
- procedure btnZoomOutClick(Sender: TObject);
- procedure btnZoomExtentsClick(Sender: TObject);
- procedure lbxLocationsClick(Sender: TObject);
- procedure FormCreate(Sender: TObject);
- procedure Open1Click(Sender: TObject);
- procedure Exit1Click(Sender: TObject);
- procedure lbxLocationsDrawItem(Control: TWinControl; Index: Integer;
- Rect: TRect; State: TOwnerDrawState);
- procedure GlobeRender(Sender: TObject);
- procedure ProjectionClick(Sender: TObject);
- procedure btnHeaderClick(Sender: TObject);
- procedure SpinButton1DownClick(Sender: TObject);
- procedure SpinButton1UpClick(Sender: TObject);
- procedure tabLayersClick(Sender: TObject);
- procedure OpenProfile1Click(Sender: TObject);
- procedure NewGlobeClick(Sender: TObject);
- procedure GlobeSelected(Sender: TObject);
- procedure GlobeMouseMove(Sender: TObject; Shift: TShiftState; X,
- Y: Integer);
- procedure GlobeRenderAttributes(Sender: TObject;
- GlobeObject: TGlobeObject; var Done: Boolean);
- procedure ThematicMapping1Click(Sender: TObject);
- procedure Timer1Timer(Sender: TObject);
- procedure Print1Click(Sender: TObject);
- private
- { Private declarations }
- public
- { Public declarations }
- procedure RebuildTabs;
- procedure LoadFile( const sFname : string );
- procedure LoadProfile( const sPname : string );
- end;
-
- {-------------------------------------------------------------------------}
- var
- frmMain: TfrmMain;
- gCurrentLayer : TGlobeLayer;
- MyObject : TGlobeSymbol;
-
- {-------------------------------------------------------------------------}
- implementation
-
- {$R *.DFM}
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.RebuildTabs;
- var
- idx : integer;
- begin
- with tabLayers do
- begin
- Tabs.Clear;
- for idx := 0 to Globe.LayerCount - 1 do
- Tabs.AddObject( Globe[idx].Name, Globe[idx] );
- if Tabs.Count > 0 then
- TabIndex := 0;
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.LoadFile( const sFname : string );
- var
- ALayer : TGlobeLayer;
- begin
- with tablayers do
- begin
- ALayer := Globe.LayerNew( '' );
- ALayer.MaxFontHeight := 10; { default font height }
- ALayer.LoadFromFile( sFname );
-
- Tabs.AddObject( ALayer.Name, ALayer );
- TabIndex := Tabs.Count - 1;
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.NewGlobeClick(Sender: TObject);
- begin
- lbxLocations.Clear;
- tabLayers.Tabs.Clear;
- Globe.Clear;
- MyObject := nil;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.LoadProfile( const sPname : string );
- begin
- NewGlobeClick( nil );
- Globe.ProfileName := sPname;
- RebuildTabs;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.SpinButton1DownClick(Sender: TObject);
- begin
- with Globe do
- ScaleFactor := ScaleFactor / 1.1;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.SpinButton1UpClick(Sender: TObject);
- begin
- with Globe do
- ScaleFactor := ScaleFactor * 1.1;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.btnZoomInClick(Sender: TObject);
- begin
- with Globe do
- ScaleFactor := ScaleFactor * 2;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.btnZoomOutClick(Sender: TObject);
- begin
- with Globe do
- ScaleFactor := ScaleFactor / 2;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.btnZoomExtentsClick(Sender: TObject);
- begin
- with Globe do
- if SelectedObject <> nil then
- begin
- ViewRect := SelectedObject.BoundsRectLL;
- ObjectLocate( SelectedObject );
- end
- else
- ViewRect := Rect( 0, 0, 0, 0 );
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.lbxLocationsClick(Sender: TObject);
- begin
- with lbxLocations do
- if ItemIndex <> -1 then
- begin
- Globe.SelectedObject := TGlobeObject( Items.Objects[ItemIndex] );
- Globe.ObjectLocate( TGlobeObject( Items.Objects[ItemIndex] ));
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.FormCreate(Sender: TObject);
- var
- ALayer : TGlobeLayer;
- begin
- LoadProfile( 'tglobe.prf' ); { load the default profile }
-
- ALayer := Globe.LayerNew( 'Animated' );
- ALayer.Animated := True;
- ALayer.ScaleFont := False;
- MyObject := TGlobeSymbol.Create( ALayer, 'AirCraft', 0, 0, 81 );
- MyObject.ObjectFont := TGlobeFont.Define( ALayer, 'WingDings', clRed, NauticalMile, 20, 0, [] );
-
- Globe.ViewRect := Rect( 0, 0, 0, 0 );
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.Exit1Click(Sender: TObject);
- begin
- Close;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.Open1Click(Sender: TObject);
- begin
- with OpenDialog1 do
- begin
- InitialDir := ExtractFilePath(Application.ExeName);
- FileName := '';
-
- if Execute then
- LoadFile( FileName );
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.OpenProfile1Click(Sender: TObject);
- begin
- with OpenDialog3 do
- begin
- InitialDir := ExtractFilePath(Application.ExeName);
- FileName := Globe.ProfileName;
- if Execute then
- LoadProfile( FileName );
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.lbxLocationsDrawItem(Control: TWinControl;
- Index: Integer; Rect: TRect; State: TOwnerDrawState);
- var
- oObj : TGlobeObject;
- begin
- with lbxLocations do
- begin
- oObj := TGlobeObject( Items.Objects[Index] );
- Canvas.TextRect( Rect, Rect.Left, Rect.Top, Copy( oObj.ClassName, 7, 255 ));
-
- Rect.Left := btnType.Width;
- Canvas.TextRect( Rect, Rect.Left, Rect.Top, oObj.Title);
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.btnHeaderClick(Sender: TObject);
- var
- idx, jdx : integer;
- iGap : integer;
- lExchanges : Longint;
- bSwap : Boolean;
- begin
- Screen.Cursor := crHourGlass;
- with lbxLocations do
- begin
- Items.BeginUpdate;
-
- bSwap := False;
-
- iGap := Items.Count - 1;
- repeat
- iGap := Trunc( iGap / 1.3 );
- Case iGap of
- 0 : iGap := 1;
- 9,10 : iGap := 11;
- end;
-
- lExchanges := 0;
- for idx := 0 to Items.Count - 1 - iGap do
- begin
- jdx := idx + iGap;
-
- case TBitBtn( Sender ).Tag of
- 0 : { By Type }
- bSwap := TGlobeObject( Items.objects[idx]).ClassName > TGlobeObject( Items.objects[jdx]).ClassName;
- 1 : { By Title }
- bSwap := TGlobeObject( Items.objects[idx]).Title > TGlobeObject( Items.objects[jdx]).Title;
- end;
-
- if bSwap then
- begin
- Items.Exchange( idx, jdx );
- Inc( lExchanges );
- end;
- end;
- until ( lExchanges = 0 ) and ( iGap = 1 );
-
- Items.EndUpdate;
- end;
- Screen.Cursor := crDefault;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.GlobeRender(Sender: TObject);
- var
- iLeft, iTop, iBkMode, iTA : integer;
- Units : TGlobeUnits;
- begin
- iLeft := Globe.Width - ( 50 + Screen.PixelsPerInch );
- iTop := Globe.Height - 50;
- with Globe.GlobeCanvas do
- begin
- Font.Assign( Self.Font );
-
- iBkMode := SetBkMode( Handle, TRANSPARENT );
- iTA := SetTextAlign( Handle, TA_CENTER );
-
- Font.Color := clRed;
- TextOut( iLeft, iTop, '0' );
- Units := KiloMeter;
- if GlobeUnitsTo( Globe.GlobeUnitsPerInch, KiloMeter ) < 10 then
- if GlobeUnitsTo( Globe.GlobeUnitsPerInch, Meter ) < 10 then
- Units := Centimeter
- else
- Units := Meter;
-
- Font.Color := clRed;
- TextOut( iLeft + Screen.PixelsPerInch, iTop,
- Format( '%d %s',[GlobeUnitsTo( Globe.GlobeUnitsPerInch, Units ), UnitsToStr( Units )] ));
-
- SetBkMode( Handle, iBkMode );
- SetTextAlign( Handle, iTA );
-
- Pen.color := clRed;
- MoveTo( iLeft, iTop + 16 );
- LineTo( iLeft, iTop + 20 );
- LineTo( iLeft + Screen.PixelsPerInch, iTop + 20 );
- LineTo( iLeft + Screen.PixelsPerInch, iTop + 15 );
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.ProjectionClick(Sender: TObject);
- begin
- Spherical1.Checked := False;
- Mercator1.Checked := False;
- Cartesian1.Checked := False;
-
- with Sender as TmenuItem do
- Checked := True;
-
- if Spherical1.Checked then
- Globe.Projection := gpSpherical;
- if Mercator1.Checked then
- Globe.Projection := gpMercator;
- if Cartesian1.Checked then
- Globe.Projection := gpCartesian;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.tabLayersClick(Sender: TObject);
- var
- iPoints, idx : integer;
- begin
- Screen.Cursor := crHourGlass;
-
- with lbxLocations do
- try
- Items.BeginUpdate;
- Clear;
-
- iPoints := 0;
- with tabLayers do
- if TabIndex <> -1 then
- begin
- gCurrentLayer := TGlobeLayer( Tabs.Objects[TabIndex] );
- with gCurrentLayer do
- begin
- for idx := 0 to ObjectCount - 1 do
- if idx < 32700 then
- if ( Objects[idx] is TGlobePolyline ) then
- begin
- Items.AddObject( '', Objects[idx] );
- Inc( iPoints, TGLobePolyLine( Objects[idx] ).LLPointList.Count )
- end
- else
- if ( Objects[idx] is TGlobeText ) then
- begin
- Items.AddObject( '', Objects[idx] );
- Inc( iPoints );
- end;
- pnlHint.Caption := Format( 'Objects %d'#10'Points %d', [ObjectCount, iPoints] );
- end;
- end;
- finally
- Items.EndUpdate;
- Screen.Cursor := crDefault;
- end;
- end;
-
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.GlobeSelected(Sender: TObject);
- var
- idx : integer;
- begin
- if Globe.SelectedObject <> nil then
- begin
- btnZoomExtents.Caption := 'Object Extents';
- if gCurrentLayer <> Globe.SelectedObject.Layer then
- with TabLayers do
- for idx := 0 to Tabs.Count - 1 do
- if TGlobeLayer( Tabs.objects[idx] ) = Globe.SelectedObject.Layer then
- begin
- tabIndex := idx;
- Break;
- end;
-
- with lbxLocations do
- ItemIndex := Items.IndexOfObject( Globe.SelectedObject );
- end
- else
- btnZoomExtents.Caption := 'World Extents';
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.GlobeMouseMove(Sender: TObject; Shift: TShiftState; X,
- Y: Integer);
- var
- sTmp : string;
- pt : TPointLL;
- MouseObj : TGlobeObject;
- begin
- with Globe do
- begin
- DeviceXYToLL( X, Y, pt );
-
- with pt do
- sTmp := LLToStr( X, '%d.%m.%s.%t%E ' ) + LLToStr( Y, '%d.%m.%s.%t%N' );
-
- MouseObj := ObjectAtXY( X, Y );
- if MouseObj <> nil then
- sTmp := sTmp + ' ' + MouseObj.Title;
-
- pnlHint.Caption := Format( ' Mouse Position: %s', [sTmp] );
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.ThematicMapping1Click(Sender: TObject);
- begin
- ThematicMapping1.Checked := not ThematicMapping1.Checked;
- Globe.Redraw;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.GlobeRenderAttributes(Sender: TObject;
- GlobeObject: TGlobeObject; var Done: Boolean);
- const
- aColors: array[0..13] of TColor = (clBlack,clMaroon,clGreen,clOlive,clPurple,
- clTeal,clGray,clSilver,clRed,clLime,clYellow,clBlue,clFuchsia,clWhite);
- begin
- if ThematicMapping1.Checked then
- if GlobeObject is TGlobePolygon then
- if GlobeObject.Layer.Name = 'Countries' then
- begin
- Globe.GlobeCanvas.Brush.Color := aColors[( GlobeObject.Index mod 14)];
- Globe.GlobeCanvas.Pen.Color := aColors[( GlobeObject.Index mod 14)];
- Done := True;
- end;
- end;
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.Timer1Timer(Sender: TObject);
- var
- ix, iY : integer;
- begin
- if MyObject <> nil then
- with MyObject.Origin do
- begin
- iX := ( X + GU_DEGREE ) mod GU_360_DEGREE;
- iY := Round( 45 * GU_DEGREE * Sin( AngleToRadians( X )));
- MyObject.Origin := PointLL( ix, iY );
- MyObject.RedrawObject;
- end;
- end;
-
-
- {-------------------------------------------------------------------------}
- procedure TfrmMain.Print1Click(Sender: TObject);
- begin
- Globe.Print;
- end;
-
- end.
-